home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue30 / startup / TBLINFO.PAS next >
Encoding:
Pascal/Delphi Source File  |  1997-12-01  |  7.3 KB  |  253 lines
  1. unit TblInfo;
  2.  
  3. {$ifdef Ver80} { Delphi 1.0x }
  4.   {$define DelphiLessThan3}
  5. {$endif}
  6. {$ifdef Ver90} { Delphi 2.0x }
  7.   {$define DelphiLessThan3}
  8. {$endif}
  9. {$ifdef Ver93} { C++ Builder 1.0x }
  10.   {$define DelphiLessThan3}
  11. {$endif}
  12.  
  13. interface
  14.  
  15. uses
  16.   Classes;
  17.  
  18. { Like the RTTI structures these records are the }
  19. { closest we can get to the internal field and method }
  20. { tables. Strings are stored like Delphi 1 strings }
  21. { (length prefixed) but have no slack space at the end. }
  22. { This is why all the routines exist - to return the }
  23. { address of things following these space-efficient strings }
  24.  
  25. type
  26. {$ifdef Win32}
  27.   {$LongStrings Off}
  28. {$endif}
  29.   PFieldClassTable = ^TFieldClassTable;
  30.   TFieldClassTable = packed record
  31.     Count: Smallint;
  32.     Classes: array[0..8191] of {$ifndef DelphiLessThan3}^{$endif}TPersistentClass;
  33.   end;
  34.  
  35.   PFieldTableEntry = ^TFieldTableEntry;
  36.   TFieldTableEntry = packed record
  37.     Offset: Integer;
  38.     ClassIndex: Smallint; { index into class table (multiplied by 4 in 16-bit) }
  39.     Name: String; { No padding is stored, so physical }
  40.   end;            { amount of storage is variable }
  41.  
  42.   PFieldTable = ^TFieldTable;
  43.   TFieldTable = packed record
  44.     Count: Smallint;
  45.     FieldClassTable: Cardinal; { offset only in 16-bit }
  46.     {Classes: array[0..8191] of TFieldTableEntry;}
  47.   end;
  48.  
  49.   PMethodTableEntry = ^TMethodTableEntry;
  50.   TMethodTableEntry = packed record
  51. {$ifdef Win32}
  52.     Size: Smallint;
  53. {$endif}
  54.     Vector: Pointer;
  55.     Name: String; { No padding is stored, so physical }
  56.   end;            { amount of storage is variable }
  57.  
  58.   PMethodTable = ^TMethodTable;
  59.   TMethodTable = packed record
  60.     Count: Smallint;
  61.     {Entries: array[0..8191] of TMethodTableEntry;}
  62.   end;
  63. {$ifdef Win32}
  64.   {$LongStrings On}
  65. {$endif}
  66.  
  67. function GetFieldTable(AClass: TClass): PFieldTable;
  68. function GetFieldTableEntry(FieldTable: PFieldTable): PFieldTableEntry;
  69. function GetNextFieldTableEntry(FieldTableEntry: PFieldTableEntry): PFieldTableEntry;
  70. function GetFieldClassTable(AClass: TClass): PFieldClassTable;
  71. procedure GetDataFieldNames(AClass: TClass; List: TStrings);
  72.  
  73. function GetMethodTable(AClass: TClass): PMethodTable;
  74. function GetMethodTableEntry(MethodTable: PMethodTable): PMethodTableEntry;
  75. function GetNextMethodTableEntry(MethodTableEntry: PMethodTableEntry): PMethodTableEntry;
  76. procedure GetMethodNames(AClass: TClass; List: TStrings);
  77.  
  78. implementation
  79.  
  80. uses
  81.   Forms, SysUtils, WinTypes;
  82.  
  83. type
  84.   PPointer = ^Pointer;
  85.  
  86. const
  87. {$ifdef Ver80} { Delphi 1 }
  88.   vmtFieldTable = -30;
  89.   vmtMethodTable = -28;
  90. {$endif}
  91. {$ifdef Ver90} { Delphi 2}
  92.   vmtFieldTable = -40;
  93.   vmtMethodTable = -36;
  94. {$endif}
  95. {$ifdef Ver93} { BCB 1 }
  96.   vmtFieldTable = -40;
  97.   vmtMethodTable = -36;
  98. {$endif}
  99.   ftClassTable = 2;
  100.  
  101.  
  102. function GetFieldTable(AClass: TClass): PFieldTable;
  103. begin
  104. {$ifdef Win32}
  105.   Result := PPointer(Longint(AClass) + vmtFieldTable)^
  106. {$else}
  107.   Result := PFieldTable(
  108.     Ptr(PtrRec(AClass).Seg,
  109.         PWord(Longint(AClass)+ vmtFieldTable)^))
  110. {$endif}
  111. end;
  112.  
  113. function GetFieldTableEntry(FieldTable: PFieldTable): PFieldTableEntry;
  114. begin
  115.   Result := nil;
  116.   if Assigned(FieldTable) and (FieldTable^.Count > 0) then
  117.     Result := PFieldTableEntry(Longint(FieldTable) +
  118.       SizeOf(FieldTable^.Count) +
  119.       SizeOf(FieldTable^.FieldClassTable))
  120. end;
  121.  
  122. function GetNextFieldTableEntry(FieldTableEntry: PFieldTableEntry): PFieldTableEntry;
  123. begin
  124.   Result := nil;
  125.   if Assigned(FieldTableEntry) then
  126.     Result := PFieldTableEntry(Longint(FieldTableEntry) +
  127.       SizeOf(FieldTableEntry^.Offset) +
  128.       SizeOf(FieldTableEntry^.ClassIndex) +
  129.       Succ(Length(FieldTableEntry^.Name)))
  130. end;
  131.  
  132. function GetFieldClassTable(AClass: TClass): PFieldClassTable;
  133. var
  134.   FieldTable: PFieldTable;
  135. begin
  136.   Result := nil;
  137.   FieldTable := GetFieldTable(AClass);
  138.   if Assigned(FieldTable) then
  139. {$ifdef Win32}
  140.     Result := PFieldClassTable(FieldTable^.FieldClassTable)
  141. {$else}
  142.     Result := PFieldClassTable(
  143.       Ptr(PtrRec(AClass).Seg, FieldTable^.FieldClassTable))
  144. {$endif}
  145. end;
  146.  
  147. procedure GetDataFieldNames(AClass: TClass; List: TStrings);
  148. var
  149.   FieldTable: PFieldTable;
  150.   FieldTableEntry: PFieldTableEntry;
  151.   FieldClassTable: PFieldClassTable;
  152.   Loop: Integer;
  153. begin
  154.   List.BeginUpdate;
  155.   try
  156.     while AClass <> TForm do
  157.     begin
  158.       FieldTable := GetFieldTable(AClass);
  159.       if Assigned(FieldTable) then
  160.       begin
  161.         FieldTableEntry := GetFieldTableEntry(FieldTable);
  162.         FieldClassTable := GetFieldClassTable(AClass);
  163.         if Assigned(FieldTableEntry) then
  164.           for Loop := 1 to FieldTable^.Count do
  165.           begin
  166.             { Add a nice string as well as storing the address }
  167.             { of the entry just in case it proves useful }
  168.             List.AddObject(Format('%s: %s (offset $%x)',
  169.               [FieldTableEntry^.Name,
  170.                FieldClassTable^.Classes[FieldTableEntry^.ClassIndex
  171.                  {$ifdef Windows}shr 2{$endif}].ClassName,
  172.                FieldTableEntry^.Offset]),
  173.                TObject(FieldTableEntry));
  174.             { Get next entry }
  175.             FieldTableEntry := GetNextFieldTableEntry(FieldTableEntry)
  176.           end
  177.       end;
  178.       { Remember form inheritance. Loop bacck until TForm is found }
  179.       AClass := AClass.ClassParent
  180.     end
  181.   finally
  182.     List.EndUpdate
  183.   end
  184. end;
  185.  
  186. function GetMethodTable(AClass: TClass): PMethodTable;
  187. begin
  188. {$ifdef Win32}
  189.   Result := PPointer(Longint(AClass) + vmtMethodTable)^
  190. {$else}
  191.   Result := PMethodTable(
  192.     Ptr(PtrRec(AClass).Seg,
  193.         PWord(Longint(AClass)+ vmtMethodTable)^))
  194. {$endif}
  195. end;
  196.  
  197. function GetMethodTableEntry(MethodTable: PMethodTable): PMethodTableEntry;
  198. begin
  199.   Result := nil;
  200.   if Assigned(MethodTable) and (MethodTable^.Count > 0) then
  201.     Result := PMethodTableEntry(Longint(MethodTable) +
  202.       SizeOf(MethodTable^.Count))
  203. end;
  204.  
  205. function GetNextMethodTableEntry(MethodTableEntry: PMethodTableEntry): PMethodTableEntry;
  206. begin
  207.   Result := nil;
  208.   if Assigned(MethodTableEntry) then
  209.     Result := PMethodTableEntry(Longint(MethodTableEntry) +
  210. {$ifdef Win32}
  211.       MethodTableEntry^.Size)
  212. {$else}
  213.       SizeOf(MethodTableEntry^.Vector) +
  214.       Succ(Length(MethodTableEntry^.Name)))
  215. {$endif}
  216. end;
  217.  
  218. procedure GetMethodNames(AClass: TClass; List: TStrings);
  219. var
  220.   MethodTable: PMethodTable;
  221.   MethodTableEntry: PMethodTableEntry;
  222.   Loop: Integer;
  223. begin
  224.   List.BeginUpdate;
  225.   try
  226.     while AClass <> TForm do
  227.     begin
  228.       MethodTable := GetMethodTable(AClass);
  229.       if Assigned(MethodTable) then
  230.       begin
  231.         MethodTableEntry := GetMethodTableEntry(MethodTable);
  232.         if Assigned(MethodTableEntry) then
  233.           for Loop := 1 to MethodTable^.Count do
  234.           begin
  235.             { Add a nice string as well as storing the address }
  236.             { of the entry just in case it proves useful }
  237.             List.AddObject(Format('%s (address $%p)',
  238.               [MethodTableEntry^.Name, MethodTableEntry^.Vector]),
  239.                TObject(MethodTableEntry));
  240.             { Get next entry }
  241.             MethodTableEntry := GetNextMethodTableEntry(MethodTableEntry)
  242.           end
  243.       end;
  244.       { Remember form inheritance. Loop bacck until TForm is found }
  245.       AClass := AClass.ClassParent
  246.     end
  247.   finally
  248.     List.EndUpdate
  249.   end
  250. end;
  251.  
  252. end.
  253.